HyperLib 1997 Winter - Disc 1/HYPERLIB-1997-Winter-CD1.ISO.7z/HYPERLIB-1997-Winter-CD1.ISO/オンラインウェア/PRG/ICProgKit 1.3.sit/ICProgKit1.3/Goodies/ICeTEe/ICeTEe.p

Text File | 1996-07-20 | 10KB | 400 lines

unit ICeTEe;

interface

    procedure Main;

implementation

    uses
        Processes, SysEqu, Notification, Traps,

        ShowInit75,

        ICTypes, ICCAPI;

    const
        MenuFlash = $A24;
        ToolScratch = $9CE;

    const
        kCreator = 'ICTE';

    const
        (* EXCL *)
        rExclusions = 128;

        (* ICN# *)
        rICTEIcon = 128;
        rFailedIcon = 129;

        (* STR# *)
        rErrorStrings = 128;
        strMiscErr = 1;
        strNoCMErr = 2;
        strNoICErr = 3;
        strInsufficientICErr = 4;
        strNoMemoryErr = 5;
        strCantFindHelperErr = 6;
        strNoHelperErr = 7;
        strNoURLErr = 8;
        strCantHackIt = 9;

    const
        noCMErr = -6660;

    type
        exArray = array[1..1000] of OSType;
        exPtr = ^exArray;
        exHandle = ^exPtr;

        icteGlobals = record
                signature: OSType;
                version: NumVersion;
                exclusions: exHandle;
                errors: Handle;
                old_teclick: ProcPtr;
            end;
        icteGlobalsPtr = ^icteGlobals;
        icteGlobalsPtrPtr = ^icteGlobalsPtr;

    function GetIndStrH (h: handle; index: integer): str255;
    (* Stolen directly from PNL's MyStrH unit *)
        var
            count, i: integer;
            s: str255;
            ps: longInt;
    begin
        count := integerPtr(h^)^;
        if (1 <= index) and (index <= count) then begin
            ps := SizeOf(integer);
            for i := 1 to index - 1 do
                ps := ps + BAND(ptr(ord(h^) + ps)^, $FF) + 1;
            BlockMove(ptr(ord(h^) + ps), @s, BAND(ptr(ord(h^) + ps)^, $FF) + 1);
        end
        else begin
            s := '';
        end;
        GetIndStrH := s;
    end;

    function DecStr (l: longint): Str32;
        var
            tmp: Str255;
    begin
        NumToString(l, tmp);
        DecStr := tmp;
    end; (* DecStr *)

    function GetMyGlobals: icteGlobalsPtr;
    begin
        GetMyGlobals := icteGlobalsPtrPtr(@Main)^;
    end; (* GetMyGlobals *)

    procedure SetMyGlobals (globals: icteGlobalsPtr);
        var
            tmp: icteGlobalsPtrPtr;
    begin
        tmp := icteGlobalsPtrPtr(@Main);
        tmp^ := globals;
    end; (* SetMyGlobals *)

    function CurrentProcessExcluded: boolean;
        var
            PSN: ProcessSerialNumber;
            info: ProcessInfoRec;
            exclusions: exHandle;
            i: integer;
    begin
        PSN.highLongOfPSN := 0;
        PSN.lowLongOfPSN := kCurrentProcess;
        info.processInfoLength := sizeof(ProcessInfoRec);
        info.processName := nil;
        info.processAppSpec := nil;
        if GetProcessInformation(PSN, info) = noErr then begin
            exclusions := GetMyGlobals^.exclusions;
            CurrentProcessExcluded := false;
            for i := 1 to GetHandleSize(Handle(exclusions)) div 4 do begin
                if exclusions^^[i] = info.processSignature then begin
                    CurrentProcessExcluded := true;
                    leave;
                end; (* if *)
            end; (* for *)
        end
        else begin
            CurrentProcessExcluded := true;
        end; (* if *)
    end; (* CurrentProcessExcluded *)

    function HaveComponentManager: boolean;
        var
            response: longint;
    begin
        HaveComponentManager := (Gestalt(gestaltComponentMgr, response) = noErr);
    end; (* HaveComponentManager *)

    function DoCommandClick (teh: TEHandle; selStart, selEnd: longint): ICError;
        var
            inst: ComponentInstance;
            err: ICError;
            err2: ICError;
            text: Handle;
            s: signedByte;
            rgn: RgnHandle;
            i: integer;
            junklong: longint;
            hint, at: Str31;
            urlh: Handle;
            tmpSelStart, tmpSelEnd: longint;
    begin
        if HaveComponentManager then begin
            err := ICCStart(inst, kCreator);
        end
        else begin
            err := noCMErr;
        end; (* if *)
        if err = noErr then begin
            err := ICCFindConfigFile(inst, 0, nil);
            if err = noErr then begin
                text := Handle(TEGetText(teh));
                s := HGetState(text);
                HLock(text);
                urlh := NewHandle(0);
                hint := 'mailto';
                tmpSelStart := selStart;
                tmpSelEnd := selEnd;
                err := ICCParseURL(inst, hint, text^, GetHandleSize(text), tmpSelStart, tmpSelEnd, urlh);
                if err = noErr then begin
                    hint := '';
                    at := '@';
                    if Munger(urlh, 0, @at[1], length(at), nil, 0) >= 0 then begin
                        hint := 'mailto';
                    end;
                    err := ICCLaunchURL(inst, hint, text^, GetHandleSize(text), selStart, selEnd);
                end;
                DisposeHandle(urlh);
                TESetSelect(selStart, selEnd, teh);
                if err = noErr then begin
                    for i := 1 to integerPtr(MenuFlash)^ do begin
                        Delay(5, junklong);
                        TEDeactivate(teh);
                        Delay(5, junklong);
                        TEActivate(teh);
                    end; (* for *)
                (* leave the URL selected *)
                end; (* if *)
                HSetState(text, s);
            end; (* if *)
            err2 := ICCStop(inst);
            if err = noErr then begin
                err := err2;
            end; (* if *)
        end; (* if *)
        DoCommandClick := err;
    end; (* DoCommandClick *)

    procedure MyNMResponseProc (nm: NMRecPtr);
        var
            ozone: THz;
            strh: Handle;
            junk: OSErr;
    begin
        junk := NMRemove(nm);
        ozone := GetZone;
        SetZone(SystemZone);
        strh := RecoverHandle(Ptr(nm^.nmStr));
        if strh <> nil then begin
            DisposeHandle(strh);
        end; (* if *)
        DisposePtr(Ptr(nm));
        SetZone(ozone);
    end; (* MyNMResponseProc *)

    procedure MyTEClick (teh: TEHandle; old_selStart, old_selEnd: integer);
        var
            err: ICError;
            message: Str255;
            nm: NMRecPtr;
            strindex: integer;
            strh: StringHandle;
    begin
        if not CurrentProcessExcluded then begin
            if not ((old_selStart <= teh^^.selStart) and (teh^^.selStart <= old_selEnd) and (old_selStart <= teh^^.selEnd) and (teh^^.selEnd <= old_selEnd)) then begin
                old_selStart := teh^^.selStart;
                old_selEnd := teh^^.selEnd;
            end; (* if *)
            err := DoCommandClick(teh, old_selStart, old_selEnd);
            if err <> noErr then begin
                (* can't case on the error codes because MPW Pascal does not case on longints properly *)
                if err = badComponentInstance then begin
                    strindex := strNoICErr;
                end
                else if err = noCMErr then begin
                    strindex := strNoCMErr;
                end
                else if err = badComponentSelector then begin
                    strindex := strInsufficientICErr;
                end
                else if err = memFullErr then begin
                    strindex := strNoMemoryErr;
                end
                else if err = afpItemNotFound then begin
                    strindex := strCantFindHelperErr;
                end
                else if err = icPrefNotFoundErr then begin
                    strindex := strNoHelperErr;
                end
                else if err = icNoURLErr then begin
                    strindex := strNoURLErr;
                end
                else if err = noPortErr then begin
                    strindex := strCantHackIt;
                end
                else begin
                    strindex := strMiscErr;
                end; (* if *)
                message := GetIndStrH(GetMyGlobals^.errors, strindex);
                if message <> '' then begin
                    strindex := Pos('^0', message);
                    if strindex <> 0 then begin
                        Delete(message, strindex, 2);
                        Insert(DecStr(err), message, strindex);
                    end; (* if *)
                    strh := NewString(message);
                    HLock(Handle(strh));
                    nm := NMRecPtr(NewPtrSysClear(sizeof(NMRec)));
                    if nm <> nil then begin
                        nm^.qType := ord(nmType);
                        nm^.nmMark := 0;
                        nm^.nmIcon := nil;
                        nm^.nmSound := nil;
                        nm^.nmStr := strh^;
                        nm^.nmResp := @MyNMResponseProc;
                        err := NMInstall(nm);
                    end
                    else begin
                        SysBeep(10);
                    end; (* if *)
                end; (* if *)
            end; (* if *)
        end; (* if *)
    end; (* MyTEClick *)

    procedure CallTEClick (pt: Point; fExtend: boolean; teh: TEHandle; proc: ProcPtr);
    inline
        $205F, (* move.l    (a7)+,a0            ; pop proc address    *)
        $4E90; (* jsr            (a0)                ; call proc                *)

    procedure InlinePushAll;
    inline
        $48E7, $FFFC;

    procedure InlinePopAll;
    inline
        $4CDF, $3FFF;

    procedure PascalTEClickPatch (pt: Point; fExtend: boolean; teh: TEHandle);
        var
            old_selStart, old_selEnd: integer;
            globals: icteGlobalsPtr;
            ozone: THz;
            command_key: boolean;
            km: KeyMap;
    begin
        InlinePushAll;
        globals := GetMyGlobals;
        old_selStart := teh^^.selStart;
        old_selEnd := teh^^.selEnd;
        GetKeys(km);
        command_key := km[55];
        CallTEClick(pt, fExtend, teh, globals^.old_teclick);
        if command_key and (GetHandleSize(Handle(TEGetText(teh))) > 0) then begin
            ozone := GetZone;
            SetZone(SystemZone);
            MyTEClick(teh, old_selStart, old_selEnd);
            SetZone(ozone);
        end; (* if *)
        InlinePopAll;
    end; (* PascalTEClickPatch *)

    function MyGestalt (selector: OSType; var response: longint): OSErr;
        var
            globals: icteGlobalsPtr;
    begin
        globals := GetMyGlobals;
        response := longint(globals);
        MyGestalt := noErr;
    end; (* MyGestalt *)

    procedure Main;
        var
            ozone: THz;
            err: OSErr;
            err2: OSErr;
            response: longint;
            globals: icteGlobalsPtr;
            exclusions: Handle;
            errors: Handle;
            vers: VersRecHndl;
    begin
(* Debugger; *)
        (* detach our resource *)
        DetachResource(RecoverHandle(Ptr(longintPtr(ToolScratch)^)));
        ShowIcon7(rICTEIcon, false);
        ozone := GetZone;
        SetZone(SystemZone);
        (* check for System 7 *)
        err := noErr;
        if (Gestalt(gestaltSystemVersion, response) <> noErr) | (response < $700) then begin
            err := unimpErr;
        end; (* if *)
        (* create the globals *)
        if err = noErr then begin
            globals := icteGlobalsPtr(NewPtrSysClear(sizeof(icteGlobals)));
            err := MemError;
        end; (* if *)
        if err = noErr then begin
            (* install globals *)
            SetMyGlobals(globals);
            globals := GetMyGlobals;
            (* init globals *)
            globals^.signature := kCreator;
            vers := VersRecHndl(Get1Resource('vers', 1));
            if vers <> nil then begin
                globals^.version := vers^^.numericVersion;
            end; (* if *)
            exclusions := Get1Resource('EXCL', rExclusions);
            err := HandToHand(exclusions);
            globals^.exclusions := exHandle(exclusions);
            errors := Get1Resource('STR#', rErrorStrings);
            err2 := HandToHand(errors);
            globals^.errors := errors;
            if err = noErr then begin
                err := err2;
            end; (* if *)
        end; (* if *)
        (* register gestalt *)
        if err = noErr then begin
            err := NewGestalt(kCreator, @MyGestalt);
        end; (* if *)
        if err = noErr then begin
        (* install our patch *)
            globals^.old_teclick := ProcPtr(NGetTrapAddress(_TEClick, ToolTrap));
            NSetTrapAddress(longint(@PascalTEClickPatch), _TEClick, ToolTrap);
        end; (* if *)
        (* if we got an error then we bleed memory all over the place, this is not an accident *)
        (* how many copies of the init can you reasonably fail to install??? *)
        SetZone(ozone);

        if err = noErr then begin
            ShowIcon7(rICTEIcon, true);
        end
        else begin
            ShowIcon7(rFailedIcon, true);
        end; (* if *)
    end; (* Main *)

end. (* ICeTEe *)
selStartX, selEndX: longint;
selStartX := selStart;
selEndX := selEnd;